home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Fritz: All Fritz
/
All Fritz.zip
/
All Fritz
/
FILES
/
PROGSCAL
/
PCOMPILE.LZH
/
TEST.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1985-03-05
|
14KB
|
646 lines
program test(input,output);
{ Pascal Compiler Test Program
Version 1.1
Written by John R. Naleszkiewicz
Date: October 19, 1984
Update: January 15, 1985 }
const
start = 10;
finish = 50;
type
rec = record
f1 : integer;
f2 : real;
f3 : boolean;
f4 : array[1 .. 3] of char;
end;
var
fail : boolean;
i,j : integer;
x,y : real;
b,f : boolean;
c,h : char;
ain : array[0 .. 10] of integer;
arl : array[start .. finish] of real;
abl : array[-5 .. 5] of boolean;
ach : array[1 .. 25] of char;
alist,blist : rec;
procedure ptest1;
var
i : integer;
x : real;
begin
writeln('called');
i := -10;
x := -15.0
end; { ptest1 }
procedure ptest2(i : integer; x : real; var j : integer; var y : real);
begin
writeln('called');
if i<>10 then
writeln(' Call by value integer passed incorrectly (P)');
if x<>10.0 then
writeln(' Call by value real passed incorrectly (P)');
if j<>25 then
writeln(' Call by reference integer passed incorrectly (P)');
if y<>25.0 then
writeln(' Call by reference real passed incorrectly (P)');
j := j - 1;
y := y - 1.0
end; { ptest2 }
procedure ptest3(i : integer);
begin
write(i:1);
if i>0 then
ptest3(i-1)
end; { ptest3 }
function ftest1(k : integer; z : real): integer;
begin
writeln('called');
if k<>0 then
writeln(' Call by reference integer passed incorrectly (F)');
if z<>75.0 then
writeln(' Call by reference real passed incorrectly (F)');
ftest1 := 100
end; { ftest1 }
function ftest2(m : integer): integer;
begin
if m>0 then
ftest2 := ftest2(m-1) + 2
else
ftest2 := 0;
write(m:1)
end; { ftest2 }
begin { main program }
writeln;
writeln('Pascal Compiler Test Program -- Version 1.1');
writeln;
fail := false;
writeln('If statement and logical tests (P=pass, F=fail)');
write(' Simple logical test (PP):');
if true then
write('P')
else
write('F');
if false then
writeln('F')
else
writeln('P');
write(' Logical NOT test (PP):');
if not true then
write('F')
else
write('P');
if not false then
writeln('P')
else
writeln('F');
write(' Logical AND test (PPP):');
if true and true then
write('P')
else
write('F');
if true and false then
write('F')
else
write('P');
if false and false then
writeln('F')
else
writeln('P');
write(' Logical OR test (PPP):');
if true or true then
write('P')
else
write('F');
if true or false then
write('P')
else
write('F');
if false or false then
writeln('F')
else
writeln('P');
write(' Logical comparison tests = <> < > <= >= (PPPPPPPP):');
if 10 = 10 then
write('P')
else
write('F');
if 10 <> 1 then
write('P')
else
write('F');
if 1 < 10 then
write('P')
else
write('F');
if 10 > 1 then
write('P')
else
write('F');
if 10 <= 10 then
write('P')
else
write('F');
if 1 <= 10 then
write('P')
else
write('F');
if 10 >= 10 then
write('P')
else
write('F');
if 10 >= 1 then
writeln('P')
else
writeln('F');
writeln;
write('Enter "C" <return> to continue');
read(c);
writeln;
writeln;
writeln('Variable assignment tests');
writeln(' Simple variable assignment tests');
i := 10;
writeln(' Integer stored: 10, contents: ',i:3);
j := i;
if j<>10 then
begin
write(' Integer assignment test failed, ');
writeln(j,' instead of 10');
fail := true
end;
j := -i;
writeln(' Integer stored: -10, contents: ',j:3);
if j<>-10 then
begin
write(' Integer negation test failed, ');
writeln(j,' instead of -10');
fail := true
end;
x := 10.0;
writeln(' Real stored: 1.0000E+01, contents:',x);
y := x;
if y<>10.0 then
begin
write(' Floating point assignment failed, ');
writeln(y,' instead of 1.0000E+01');
fail := true
end;
y := -x;
writeln(' Real stored: -1.0000E+01, contents:',y);
if y<>-10.0 then
begin
write(' Floating point negation failed, ');
writeln(y,' instead of -1.0000E+01');
fail := true
end;
b := true;
f := b;
if not f then
begin
write(' Boolean assignment (true) failed, ');
writeln('false instead of true');
fail := true
end;
b := false;
f := b;
if f then
begin
write(' Boolean assignment (false) failed, ');
writeln('true instead of false');
fail := true
end;
c := 'x';
h := c;
if h<>'x' then
begin
write(' Character assignment failed, ');
writeln('result of "',h,'" instead of "x"');
fail := true
end;
writeln(' Array assignment tests');
ain[0] := 25;
ain[5] := ain[0];
if ain[5]<>25 then
begin
write(' Integer array assignment failed, ');
writeln(ain[5],' instead of 25');
fail := true
end;
arl[25] := 1000.0;
arl[45] := arl[25];
if arl[45]<>1000.0 then
begin
write(' Floating point array assignment failed, ');
writeln(arl[45],' instead of 1.0000E+03');
fail := true
end;
abl[-3] := true;
abl[3] := abl[-3];
if not abl[3] then
begin
write(' Boolean array assignment (true) failed, ');
writeln('false instead of true');
fail := true
end;
abl[0] := false;
abl[5] := abl[0];
if abl[5] then
begin
write(' Boolean array assignment (false) failed, ');
writeln('true instead of false');
fail := true
end;
ach[10] := 'a';
ach[23] := ach[10];
if ach[23]<>'a' then
begin
write(' Character array assignment failed, ');
writeln('result of "',ach[23],'" instead of "a"');
fail := true
end;
writeln(' Record field assignment tests');
alist.f1 := 99;
alist.f2 := 12.5;
alist.f3 := true;
alist.f4[1] := 'a';
alist.f4[2] := 'b';
alist.f4[3] := alist.f4[1];
blist := alist;
if blist.f1<>99 then
begin
write(' Integer field assignment failed, ');
writeln(blist.f1,' instead of 99');
fail := true
end;
if blist.f2<>12.5 then
begin
write(' Real field assignment failed, ');
writeln(blist.f2,' instead of 1.2500E+01');
fail := true
end;
if not blist.f3 then
begin
write(' Boolean field assignment failed, ');
writeln('false instead of true');
fail := true
end;
if blist.f4[3]<>'a' then
begin
write(' Character array field assignment failed, ');
writeln('result of "',blist.f4[3],'" instead of "a"');
fail := true
end;
writeln('Builtin function tests');
i := 3;
if not odd(i) then
begin
write(' Function odd(x) failed, ');
writeln(i,' was found to be even');
fail := true
end;
i := 4;
if odd(i) then
begin
write(' Function odd(x) failed, ');
writeln(i,' was found to be odd');
fail := true
end;
x := 1.77;
i := round(x);
j := trunc(x);
if i<>2 then
begin
write(' Function round(x) failed, ');
writeln(i,' instead of 2');
fail := true
end;
if j<>1 then
begin
write(' Function trunc(x) failed, ');
writeln(i,' instead of 1');
fail := true
end;
i := -25;
j := abs(i);
if j <> 25 then
begin
write(' Function abs(integer) failed, ');
writeln(j,' instead of 25');
fail := true
end;
i := 99;
j := abs(i);
if j <> 99 then
begin
write(' Function abs(integer) failed, ');
writeln(j,' instead of 99');
fail := true
end;
x := -12.5;
y := abs(x);
if y <> 12.5 then
begin
write(' Function abs(real) failed, ');
writeln(y,' instead of 1.2500E+01');
fail := true
end;
x := 112.5;
y := abs(x);
if y <> 112.5 then
begin
write(' Function abs(real) failed, ');
writeln(y,' instead of 1.1250E+02');
fail := true
end;
i := 7;
j := sqr(i);
if j <> 49 then
begin
write(' Function sqr(integer) failed, ');
writeln(j,' instead of 49');
fail := true
end;
x := 5.0;
y := sqr(x);
if y <> 25.0 then
begin
write(' Function sqr(real) failed, ');
writeln(y,' instead of 2.5000E+01');
fail := true
end;
x := 729.0;
y := sqrt(x);
if y <> 27.0 then
begin
write(' Function sqrt(x) failed, ');
writeln(y,' instead of 2.7000E+01');
fail := true
end;
x := exp(1.0);
y := ln(x);
if y<>1.0 then
begin
write(' Function exp(x) or ln(x) failed, ');
writeln(y,' instead of 1.0000E+00');
fail := true
end;
writeln('Arithmetic tests');
writeln(' Integer arithmetic tests');
i := 5 + 5;
j := i + 10;
j := j + i;
if j<>30 then
begin
write(' Addition failed, ');
writeln(j,' instead of 30');
fail := true
end;
i := 20 - 8;
j := i - 10;
j := i - j;
if j<>10 then
begin
write(' Subtraction failed, ');
writeln(j,' instead of 10');
fail := true
end;
i := 2 * 3;
j := i * 4;
j := j * i;
if j<>144 then
begin
write(' Multiplication failed, ');
writeln(j,' instead of 144');
fail := true
end;
i := 100 div 5;
j := i div 10;
j := i div j;
if j<>10 then
begin
write(' Division failed, ');
writeln(j,' instead of 10');
fail := true
end;
i := 102 mod 15;
j := i mod 7;
j := i mod j;
if j<>2 then
begin
write(' MOD failed, ');
writeln(j,' instead of 2');
fail := true
end;
i := 10;
j := i + 7;
j := (j - i) * (i - 2 * j);
if j<>-168 then
begin
write(' Hierarchy failed, ');
writeln(j,' instead of -168');
fail := true
end;
writeln(' Floating point arithmetic tests');
x := 1.0 / 3.0;
x := x * 3.0;
y := 1.0 - x;
if y=0.0 then
i := 99
else
i := round(-ln(y) / ln(10.0));
writeln(' Internal accuracy (digits): ',i:2);
x := 2.0 + 3.0;
y := x + 10.2;
y := y + x;
if y<>20.2 then
begin
write(' Addition failed, ');
writeln(y,' instead of 2.0200E+01');
fail := true
end;
x := 20.0 - 8.7;
y := x - 10.3;
y := x - y;
if y<>10.3 then
begin
write(' Subtraction failed, ');
writeln(y,' instead of 1.0300E+01');
fail := true
end;
x := 2.0 * 3.0;
y := x * 4.0;
y := y * x;
if y<>144.0 then
begin
write(' Multiplication failed, ');
writeln(y,' instead of 1.4400E+02');
fail := true
end;
x := 100.0 / 5.0;
y := x / 10.0;
y := x / y;
if y<>10.0 then
begin
write(' Division failed, ');
writeln(y,' instead of 1.0000E+01');
fail := true
end;
x := 10.0;
y := x + 7.0;
y := (y - x) * (x - 2.0 * y);
if y<>-168.0 then
begin
write(' Hierarchy failed, ');
writeln(y,' instead of -1.6800E+02');
fail := true
end;
writeln;
write('Enter "C" <return> to continue');
read(c);
writeln;
writeln;
writeln('Procedure and function testing');
writeln(' Procedure call tests');
i := 0;
x := 10.0;
write(' Procedure 1 ');
ptest1;
if i<>0 then
begin
writeln(' Integer local variables damaging globals');
fail := true
end;
if x<>10.0 then
begin
writeln(' Real local variables damaging globals');
fail := true
end;
j := 25;
y := 25.0;
write(' Procedure 2 ');
ptest2(10,10.0,j,y);
if j<>24 then
begin
writeln(' Call by reference integer not returned correctly');
fail := true
end;
if y<>24.0 then
begin
writeln(' Call by reference real not returned correctly');
fail := true
end;
writeln(' Recursive procedure test (5..0)');
write(' ');
i := 5;
ptest3(i);
writeln;
if i<>5 then
begin
writeln(' Call by value in recursive test failed');
fail := true
end;
writeln(' Function call tests');
i := 0;
x := 75.0;
write(' Function 1 ');
i := ftest1(i,x);
if i<>100 then
begin
writeln(' Function not returning correct value');
fail := true
end;
writeln(' Recursive function test (0..5)');
write(' ');
i := 5;
j := ftest2(i);
writeln;
if i<>5 then
begin
writeln(' Call by value in recursive function test failed');
fail := true
end;
if j<>10 then
begin
writeln(' Function not returning correct value during recursion');
fail := true
end;
writeln;
writeln('Testing complete');
if fail then
writeln('Errors Found')
else
writeln('No Errors Found')
end.
writeln